unit uFakeLoad;

{.$DEFINE LoadManual}

interface

Uses Forms,
     Classes,
     SysUtils,
     Windows,
     Graphics,
     Registry,
     uActiveDesktop,
     uConstants,

     {$IFDEF LoadManual}
     JPEG
     {$ELSE}
     NViewLib
     {$ENDIF}
     ;

Function DesktopBMPName : String;
(* Returns the filename of the bitmap currently used for the desktop wallpaper *)

Function GetDesktopBitmap : TBitmap;
(* Returns a bitmap that respects the options of the current desktop bitmap like
   tiled, centered and offsets. *)

Function GetDesktopBitmapInfo(var rFilename : String; var rTiled : Boolean; var rStart : TPoint) : Boolean;
(* Returns information about the background bitmap *)

Type TVersionInfo = packed Record
                    Major : Byte;
                    Minor : Byte;
                    Filler : Byte;
                    Win95Indicator : Byte;
                  End;

Function Windows9xRunning : Boolean;
Function GetOSType : TOperatingSystem;

const regkeyWallpaperStandard = '\Control Panel\Desktop';
      regkeyWallpaperActiveDesktop = '\Software\Microsoft\Internet Explorer\Desktop\General';

      regvalWallpaper = 'Wallpaper';
      regvalTile = 'TileWallpaper';
      regvalPattern = 'Pattern';                                   (* A pattern is always tiled ... *)

      {Add support for offsets of wallpapers etc. - these do not come always from the registry ...}

Function WallpaperRegistryKey : String;

Function GetDesktopPattern : TBitmap;

Type TBrushPattern = packed Array[0..7] of Word;
     PBrushPattern = ^TBrushPattern;
procedure Dim256( aBitmap : TBitmap; aPattern : PBrushPattern; aColor : TColor );

Function FastTint( aBitmap : TBitmap; aColor : TColor ) : TBitmap;

Function LoadImage( Const aFilename : String ) : TBitmap;

(* Returns a synthetic background for failsafe purposes *)
Function SafeBackground : TBitmap;

implementation

Function WallpaperRegistryKey : String;
Begin
  If ActiveDesktopRunning
    then Result := regkeyWallpaperActiveDesktop
    else Result := regkeyWallpaperStandard;
End;

Function DesktopBMPName;
Var Registry : TRegistry;
Begin
  Result := '';
  Registry := TRegistry.Create;
  try
    Registry.OpenKey( WallpaperRegistryKey, False );
    Result := Registry.ReadString(regvalWallpaper);
    If not FileExists( Result )
      then Result := '';
  finally
    Registry.Free;
  End;
End;

Function GetDesktopBitmapInfo;
Var Registry : TRegistry;
Begin
  Result := True;
  Registry := TRegistry.Create;
  try
    try
      Registry.OpenKey( WallpaperRegistryKey, False );
      rFilename := Registry.ReadString(regvalWallpaper);
      If not FileExists( rFilename )
        then Result := False;
      rTiled := False;
      If Registry.ValueExists( regvalTile )
        then rTiled := (Registry.ReadString( regvalTile )='1');
      rStart.X := 0;
      rStart.Y := 0;
    except
      Result := False;
    end;
  finally
    Registry.Free;
  End;
End;

Function GetDesktopPattern;
Var I,J : Integer;
    B : Integer;
    Dummy : Integer;
    S : String;
    Number : String;

    R : TRegistry;
Begin
  Result := TBitmap.Create;
  Result.Width := 8;
  Result.Height := 8;
  Result.Canvas.Brush.Color := clBackground;
  Result.Canvas.FillRect( Rect( 0,0,8,8 ));

  R := TRegistry.Create;
  try
    R.OpenKey( regkeyWallpaperStandard, False );
    S := R.ReadString( regvalPattern );
    If S <> ''
      then
        Begin
          For I := 0 to 7 do
            Begin
              Number := '';
              While (Length( Number ) < Length( S )) and (S[ Length( Number )+1] in ['0'..'9']) do
                Number := Number + S[ Length( Number )+1];
              Delete( S,1,Length( Number )+1);
              Val( Number, B, Dummy );
              For J := 0 to 7 do
                Begin
                  If Odd(B)
                    then Result.Canvas.Pixels[(I+2) mod 8,(J+3) mod 8] := clBlack;
                  B := B shr 1;
                End;
            End;
        End;
  finally
    R.Free;
  end;
End;

Procedure DrawTiled( aTarget : TBitmap; aSource : TBitmap );
(* Draws a bitmap tiled over a canvas *)
Var X,Y : Integer;
Begin
  Y := 0;
  With aSource do
    While Y < aTarget.Height do
      Begin
        X := 0;
        While X < aTarget.Width do
          Begin
            aTarget.Canvas.Draw( X,Y, aSource );
            Inc( X, Width );
          End;
        Inc( Y, Height );
      End;
End;

Function GetDesktopBitmap;
Var S : String;
    Image : TBitmap;
    DC : hDC;
    ImageRect : TRect;
    SourceRect : TRect;
    GotImage : Boolean;
    NeedsBGFill : Boolean; (* Do we need to color the background ? *)
    Tile : Boolean;
    Offset : TPoint;

Begin
  Result := TBitmap.Create;
  Image := TBitmap.Create;
  GotImage := GetDesktopBitmapInfo( S, Tile, Offset );

  (* Guard against trying to load a web page (or an empty image) ... *)
  If (S='') or (UpperCase( Copy( S, Length( S )-4, 5 )) = '.HTML') or (UpperCase( Copy( S, Length( S )-3, 4 )) = '.HTM')
    then GotImage := False;

  try
    If GotImage
      then
        Begin
          Image.Free;
          Image := LoadImage( S );
          If Image = nil
            then Image := TBitmap.Create;
          {WriteLn( 'Loading "'+S+'" ...' );}
          {hImg := NViewLibLoad( @S[1], True );
          If hImg = 0
            then MessageBox(0, PChar( 'Error loading "' + S + '" - try converting it to .BMP format.' ),'', idOK)
            else Image.Handle := hImg;}
        End
      else {WriteLn( 'No background image ...' )};

    DC := GetDC( 0 );
    Result.Handle := CreateCompatibleBitmap( DC, Screen.Width, Screen.Height );
    ReleaseDC( 0, DC );
    Result.Width := Screen.Width;
    Result.Height := Screen.Height;

    NeedsBGFill := not GotImage or not Tile;
    If not NeedsBGFill
      then NeedsBGFill := ((Image.Width < Result.Width) or (Image.Height < Result.Height));

    If NeedsBGFill
      then
        Begin
          (* Fill the bitmap with the screen background color or with the background pattern if that's needed *)
          Result.Canvas.Brush.Bitmap := GetDesktopPattern;
          Result.Canvas.FillRect( Rect( 0,0,Result.Width,Result.Height ));
        End;

    If GotImage
      then
        Begin
          If not Tile
            then 
              Begin
                If ((Image.Width < Result.Width) or (Image.Height < Result.Height))
                  then
                    Begin
                      ImageRect := Rect( (Result.Width - Image.Width) div 2, (Result.Height - Image.Height) div 2, (Result.Width + Image.Width) div 2, (Result.Height + Image.Height) div 2 );
                      SourceRect := Rect( 0,0,Image.Width, Image.Height );
                    End
                  else
                    Begin
                      ImageRect := Rect( 0,0,Result.Width, Result.Height );
                      SourceRect := Rect( (Image.Width - Result.Width) div 2, (Image.Height - Result.Height) div 2, (Image.Width + Result.Width) div 2, (Image.Height + Result.Height) div 2 );
                    End;
                Result.Canvas.CopyRect( ImageRect, Image.Canvas, SourceRect );
              End
            else DrawTiled( Result, Image );
        End;

  finally
    Image.Free;
  end;
End;

Function Windows9xRunning : Boolean;
Var Version : LongInt;
    VersionInfo : TVersionInfo absolute Version;
Begin
  Version := GetVersion;

  Result := (VersionInfo.Win95Indicator and $80) <> 0;
End;

Function GetOSType;
Var Version : LongInt;
    VersionInfo : TVersionInfo absolute Version;
Begin
  Version := GetVersion;
  If (VersionInfo.Win95Indicator and $80) <> 0
    then
      Begin
        If (VersionInfo.Win95Indicator and $7F) = 95
          then Result := osWin95
          else Result := osWin98;
      End
    else
      Begin
        If VersionInfo.Major <= 4
          then Result := osNT4
          else Result := osNT5;
      End;
End;

procedure Dim256;
Var B : TBitmap;
    _Pattern : TBitmap;
    I,J : Integer;

begin
{
<Kalms> corion: c = *((int*) pic); int c0 = (c >> 8) & 0xff00ff; int c1 = c & 0xff00ff; c0 *= scale; c1 *= scale; c0 &= 0xff00ff00; c1 &= 0xff00ff00; c = c0 | (c1 >> 8); *((int *) pic) = c;
<Kalms> corion: scale = 0 .. 256
}
  B := TBitmap.Create;
  _Pattern := TBitmap.Create;

  try
    B.Handle := CreateBitmap( 8,8,1,1, aPattern );

    With _Pattern do
      Begin
        Width := aBitmap.Width;
        Height := aBitmap.Height;
        Canvas.Brush.Bitmap := B;
        Canvas.FillRect( Rect( 0,0, Width, Height ));
        Canvas.Brush.Bitmap := nil;
      End;

    aBitmap.Canvas.CopyMode := cmSrcAnd;
    aBitmap.Canvas.CopyRect( Rect( 0,0,aBitmap.Width,aBitmap.Height ),
                             _Pattern.Canvas,
                             Rect( 0,0,aBitmap.Width,aBitmap.Height ));
    If aColor <> clBlack
      then
        Begin
          B.Free;
          B := TBitmap.Create;
          B.Width := 8;
          B.Height := 8;
          For J := 0 to 7 do
            For I := 0 to 7 do
              If aPattern^[J] and (1 shl I) = 0
                then B.Canvas.Pixels[I,J] := aColor
                else B.Canvas.Pixels[I,J] := 0;

          With _Pattern do
            Begin
              Canvas.Brush.Bitmap := B;
              Canvas.FillRect( Rect( 0,0, Width, Height ));
              Canvas.Brush.Bitmap := nil;
            End;

          aBitmap.Canvas.CopyMode := cmSrcPaint;
          aBitmap.Canvas.CopyRect( Rect( 0,0,aBitmap.Width,aBitmap.Height ),
                                   _Pattern.Canvas,
                                   Rect( 0,0,aBitmap.Width,aBitmap.Height ));
        End;
  finally
    _Pattern.Free;
    B.ReleaseHandle;
    B.Free;
  end;
end;

Type TColorMap = Array[Byte] of LongInt;
     TColorRec = packed Record
       B,G,R : Byte;
     End;

     TColors = Array[ Byte ] of TColor;

Function FastTint;
Var R : TColorMap;
    G : TColorMap;
    B : TColorMap;
    Tint : TColors;

    C : TColor;
    _C : TColorRec absolute C;
    _Tint : TColorRec absolute aColor;
    V : Integer;

Var I : Integer;
    J : Integer;

    bmHeight : Integer;
    bmWidth : Integer;

    TargetInfo : TBitmapInfo;
    Buffer : Pointer;
    BufSize : LongInt;

    P : ^TColorRec;

    NewBMP : THandle;

    Scanlines : LongInt;

Begin
  Result := TBitmap.Create;

  (* Collect the image data *)
  FillChar( TargetInfo, SizeOf( TargetInfo ), 0 );
  With TargetInfo.bmiHeader do
    Begin
      biSize := SizeOf( TargetInfo.bmiHeader );
      biWidth := aBitmap.Width;
      biHeight := aBitmap.Height;
      biPlanes := 1;
      biBitcount := 24;
      biCompression := BI_RGB;
    End;

  (* Collect the image bits *)
  BufSize := aBitmap.Width * aBitmap.Height * SizeOf( P^ );       (* Allocate enough memory *)
  Getmem( Buffer, Bufsize );

  try
    try
      Scanlines := GetDIBits( aBitmap.Canvas.Handle, aBitmap.Handle, 0, aBitmap.Height, Buffer, TargetInfo, DIB_RGB_COLORS );
      If Scanlines = 0
        then RaiseLastWin32Error('FastTint():GetDIBits()');

      (* Set up the RGB translation table *)
      For I := 0 to 255 do
        Begin
          R[I] := Round( 0.19 * I );
          G[I] := Round( 0.57 * I );
          B[I] := Round( 0.24 * I );
          Tint[I] := Round(_Tint.R*I/255)+Round(_Tint.G*I/255) shl 8+Round(_Tint.B*I/255) shl 16;
        End;

      bmHeight := aBitmap.Height;
      bmWidth := aBitmap.Width;

      P := Buffer;
      For J := 0 to (bmHeight*bmWidth) -1 do
        Begin
          V := Min( R[P^.R] + G[P^.G] + B[P^.B], 255 );
          Move( Tint[V], P^, 3 );
          Inc( P );
        End;

      NewBMP := CreateCompatibleBitmap( aBitmap.Canvas.Handle, aBitmap.Width, Scanlines );
      If NewBMP = 0
        then RaiseLastWin32Error( 'FastTint():CreateCompatibleBitmap()' )
        else
          Begin
            Result.Handle := NewBMP;
            If SetDIBits( Result.Canvas.Handle, NewBMP, 0, Scanlines, Buffer, TargetInfo, DIB_RGB_COLORS ) = 0
              then RaiseLastWin32Error('FastTint():SetDIBits()');
          End;
    finally
      FreeMem( Buffer, BufSize );
    end;
  except on E : Exception do
    Begin
      MessageBox(0, PChar(E.Message), 'eConsole', idOK );
      Result.Free;
      Result := nil;
    End;
  end;
End;

Function LoadImage;
{$IFDEF LoadManual}
Var Ext : String;
    G : TPicture;
{$ELSE}
Var H : THandle;
{$ENDIF}
Begin
  Result := nil;

  {$IFDEF LoadManual}
  G := TPicture.Create;
  try
    Ext := '';
    While aFilename[ Length( aFilename ) - Length( Ext )] <> '.' do
      Ext := UpCase( aFilename[ Length( aFilename ) - Length( Ext )]) + Ext;

    If (Ext = 'BMP') or (Ext = 'JPG') or (Ext = 'JPEG')
      then G.LoadFromFile(aFilename);

    try
      Result := TBitmap.Create;
      Result.Width := G.Width;
      Result.Height := G.Height;
      If G.Graphic.Empty
        then
          Begin
            Result.Free;
            Result := nil;
          End
        else Result.Canvas.Draw( 0,0,G.Graphic );
    except on E : Exception do
      Begin
        Application.MessageBox( PChar( E.Message ), '', idOK );
        Result.Free;
        Result := nil;
      End;
    End;
  finally
    G.Free;
  End;
  {$ELSE}
  H := NViewLibLoad( PChar(aFilename), True );

  If H <> 0
    then
      Begin
        Result := TBitmap.Create;
        Result.Handle := H;
      End
    else MessageBox(0, PChar('Error loading "'+aFilename+'".' ), 'eConsole', idOK );
  {$ENDIF}
End;

Function SafeBackground : TBitmap;
Var I,J : Integer;
Begin
  Result := TBitmap.Create;
  With Result do
    Begin
      Width := 8;
      Height := 8;
      Canvas.Brush.Color := clBlack;
      Canvas.FillRect( Rect( 0,0, 8,8 ));
      With Canvas do
        Begin
          For J := 0 to (Height -1 )div 2 do
            For I := 0 to (Width -1) div 2 do
              Pixels[I*2,J*2] := clBlue;
        End;
    End;
End;

end.
